home *** CD-ROM | disk | FTP | other *** search
/ Archive Magazine CD 1995 / Archive Magazine CD 1995.iso / discs / prog_disc / volume_2 / issue_03 / lisp / utils next >
Encoding:
Text File  |  1990-11-20  |  3.3 KB  |  132 lines
  1. %% File utils created at 21:30:03 on 09-Nov-88 %%
  2.  
  3. %%     (c)David H Wild 1988     %%
  4.  
  5. (setq oscli interpret-string)
  6.  
  7. (setq addprop
  8.    '(lambda (sym elem prop)
  9.        (or
  10.           (member elem (get sym prop))
  11.           (put sym prop (adjoin elem (get sym prop)))) ))
  12.  
  13. (setq addprops
  14.    '(lambda (sym elem prop)
  15.        (or
  16.           (member elem (get sym prop))
  17.           (put
  18.              sym
  19.              prop
  20.              (sort (adjoin elem (get sym prop)) 'orderp)))) )
  21.  
  22. (setq adjoin
  23.    '(lambda (item list)
  24.        (cond ((member item list) list) (t (cons item list)))) )
  25.  
  26. (setq cat '(lambda nil (oscli 'cat)))
  27.  
  28. (setq compile2
  29.    '(lambda (*x*)
  30.        (do
  31.           ((fun *x* (cdr fun)) (fun2 *x* (cdr fun2)))
  32.           ((null fun) nil)
  33.           (cond
  34.              ((codep (eval (car fun)))
  35.                 (do-msg (car fun2) " done already" t))
  36.              (t (compile (list (car fun)))) ))) )
  37.  
  38. (setq compilefile '(lambda (file) (compile2 (get file 'objects))))
  39.  
  40. (setq disc-map '(lambda nil (oscli 'map)))
  41.  
  42. (setq do-msg
  43.    '(lambdaq (*x*)
  44.        (do
  45.           ((msg *x* (cdr msg)))
  46.           ((null msg) nil)
  47.           (cond
  48.              ((eq (car msg) 't) (terpri))
  49.              ((stringp (car msg)) (princ (car msg)))
  50.              (t (princ (eval (car msg)))) ))) )
  51.  
  52. (setq ex '(lambda nil (oscli 'ex)))
  53.  
  54. (setq free '(lambda nil (oscli 'free)))
  55.  
  56. (setq getrid '(lambdaq (*x*) (remob (car *x*))))
  57.  
  58. (setq insertleft
  59.    '(lambda (old new lat)
  60.        (cond
  61.           ((null lat) ('nil))
  62.           ((memberp old lat)
  63.              (cond
  64.                 ((eq (car lat) old) (cons new (cons old (cdr lat))))
  65.                 (t (cons
  66.                       (car lat)
  67.                       (insertleft old new (cdr lat)))) ))
  68.           (t lat))))
  69.  
  70. (setq insertright
  71.    '(lambda (old new lat)
  72.        (cond
  73.           ((null lat) ('nil))
  74.           ((memberp old lat)
  75.              (cond
  76.                 ((eq (car lat) old) (cons old (cons new (cdr lat))))
  77.                 (t (cons
  78.                       (car lat)
  79.                       (insertright old new (cdr lat)))) ))
  80.           (t lat))))
  81.  
  82. (setq memberp
  83.    '(lambda (item list) (cond ((member item list) t) (t nil))))
  84.  
  85. (setq princomfun '(lambdaq (fun) (pp (userdef (car fun)))) )
  86.  
  87. (setq printdef
  88.    '(lambda (objs)
  89.        (progn
  90.           (oscli "ignore 10")
  91.           (printon)
  92.           (do-msg "Listing printed on " (date) " at " (timeofday) t
  93.              t)
  94.           (dolist
  95.              (x objs)
  96.              (let
  97.                 ((y (userdef x)))
  98.                 (underline-on)
  99.                 (pp x)
  100.                 (underline-off)
  101.                 (pp y)))
  102.           (eject)
  103.           (printoff)
  104.           (oscli "ignore"))))
  105.  
  106. (setq printfiledefs
  107.    '(lambda (file) (printdef (sort (get file 'objects) 'orderp))))
  108.  
  109. (setq printoff '(lambda nil (oscli "fx3,64") (vdu 3)))
  110.  
  111. (setq printon '(lambda nil (oscli "fx3,8")))
  112.  
  113. (setq show '(lambda nil (interpret-string 'show)))
  114.  
  115. (setq subprop
  116.    '(lambda (sym elem prop)
  117.        (put sym prop (setdiff (get sym prop) (list elem)))) )
  118.  
  119. (setq underline-off '(lambda nil (vdu 27 45 0)))
  120.  
  121. (setq underline-on '(lambda nil (vdu 27 45 1)))
  122.  
  123.  
  124. (put
  125.    'utils
  126.    'objects
  127.    '(addprop addprops adjoin blue blue3 cat compile2 compilefile
  128.        disc-map do-msg ex free getrid insertleft insertright memberp
  129.        princomfun printdef printfiledefs printoff printon show
  130.        subprop underline-off underline-on))
  131.  
  132.